home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swaga_c.zip / ANSI.SWG / 0029_Full ANSI Output unit.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-03  |  25KB  |  641 lines
  1.  
  2. { A unit to implement FULL ANSI output.  Useful for a BBS or DOOR program
  3.   where you would want to send string out over the modem.  Simply call
  4.   your modem routine to :
  5.  
  6.              SENDSTRING(port,ANSIGoToXY(1,1))
  7.  
  8.   Would reposition the cursor on the remote terminal.  Get the idea ??
  9.  
  10.   The thing will EVEN play ANSI music !!
  11.  
  12.   Gayle Davis 1/24/94
  13.  
  14.  
  15.  
  16. }
  17.  
  18. UNIT AnsiIO;
  19.  
  20. INTERFACE
  21.  
  22.    USES
  23.       CRT,
  24.       Graph3;
  25.  
  26.    FUNCTION ANSIClrScr : string;
  27.    FUNCTION ANSIClrEol : string;
  28.    FUNCTION ANSIGotoXY(X, Y : word) : string;
  29.    FUNCTION ANSIUp(Lines : word) : string;
  30.    FUNCTION ANSIDown(Lines : word) : string;
  31.    FUNCTION ANSIRight(Cols : word) : string;
  32.    FUNCTION ANSILeft(Cols : word) : string;
  33.    FUNCTION ANSIColor(Fg, Bg : integer) : string;
  34.    FUNCTION ANSIMusic(s : string) : string;
  35.    PROCEDURE ANSIWrite(s : string);
  36.    PROCEDURE ANSIWriteLn(s : string);
  37.  
  38. IMPLEMENTATION
  39.  
  40.    CONST
  41.       ColorArray : array[0..7] of integer = (0,4,2,6,1,5,3,7);
  42.  
  43.    VAR
  44.       Bold, TruncateLines : boolean;
  45.       Vari, Octave, Numb : integer;
  46.       Test, Dly, Intern, DlyKeep : longInt;
  47.       Flager, ChartoPlay : char;
  48.       Typom, Min1, Adder : real;
  49.  
  50. {****************************************************************************}
  51. {***                                                                      ***}
  52. {***       Function that returns the ANSI code for a Clear Screen.        ***}
  53. {***                                                                      ***}
  54. {****************************************************************************}
  55.    FUNCTION ANSIClrScr : string;
  56.       BEGIN
  57.          ANSIClrScr := #27+'[2J';
  58.       END;
  59.  
  60. {****************************************************************************}
  61. {***                                                                      ***}
  62. {***    Function that returns the ANSI code for a Clear to End of Line.   ***}
  63. {***                                                                      ***}
  64. {****************************************************************************}
  65.    FUNCTION ANSIClrEol : string;
  66.       BEGIN
  67.          ANSIClrEol := #27+'[K';
  68.       END;
  69.  
  70. {****************************************************************************}
  71. {***                                                                      ***}
  72. {***   Function that returns the ANSI code to move the cursor to (X,Y).   ***}
  73. {***                                                                      ***}
  74. {****************************************************************************}
  75.    FUNCTION ANSIGotoXY(X, Y : word) : string;
  76.       VAR
  77.          XStr, YStr : string;
  78.  
  79.       BEGIN
  80.          str(X,XStr);
  81.          str(Y,YStr);
  82.          ANSIGotoXY := #27+'['+YStr+';'+XStr+'H';
  83.       END;
  84.  
  85. {****************************************************************************}
  86. {***                                                                      ***}
  87. {***  Function that returns the ANSI code to move the cursor up "Lines"   ***}
  88. {***                         number of lines.                             ***}
  89. {***                                                                      ***}
  90. {****************************************************************************}
  91.    FUNCTION ANSIUp(Lines : word) : string;
  92.       VAR
  93.          LinesStr : string;
  94.  
  95.       BEGIN
  96.          str(Lines,LinesStr);
  97.          ANSIUp := #27+'['+LinesStr+'A';
  98.       END;
  99.  
  100. {****************************************************************************}
  101. {***                                                                      ***}
  102. {***  Function that returns the ANSI code to move the cursor down "Lines" ***}
  103. {***                        number of lines.                              ***}
  104. {***                                                                      ***}
  105. {****************************************************************************}
  106.    FUNCTION ANSIDown(Lines : word) : string;
  107.       VAR
  108.          LinesStr : string;
  109.  
  110.       BEGIN
  111.          str(Lines,LinesStr);
  112.          ANSIDown := #27+'['+LinesStr+'B';
  113.       END;
  114.  
  115. {****************************************************************************}
  116. {***                                                                      ***}
  117. {***     Function that returns the ANSI code to move the cursor "Cols"    ***}
  118. {***                         positions forward.                           ***}
  119. {***                                                                      ***}
  120. {****************************************************************************}
  121.    FUNCTION ANSIRight(Cols : word) : string;
  122.       VAR
  123.          ColsStr : string;
  124.  
  125.       BEGIN
  126.          str(Cols,ColsStr);
  127.          ANSIRight := #27+'['+ColsStr+'C';
  128.       END;
  129.  
  130. {****************************************************************************}
  131. {***                                                                      ***}
  132. {***     Function that returns the ANSI code to move the cursor "Cols"    ***}
  133. {***                        positions backward.                           ***}
  134. {***                                                                      ***}
  135. {****************************************************************************}
  136.    FUNCTION ANSILeft(Cols : word) : string;
  137.       VAR
  138.          ColsStr : string;
  139.  
  140.       BEGIN
  141.          str(Cols,ColsStr);
  142.          ANSILeft := #27+'['+ColsStr+'D';
  143.       END;
  144.  
  145.  
  146. {****************************************************************************}
  147. {***                                                                      ***}
  148. {***    Function that returns the ANSI code to change the screen color    ***}
  149. {***             to an "Fg" foreground and a "Bg" background.             ***}
  150. {***                                                                      ***}
  151. {****************************************************************************}
  152.    FUNCTION ANSIColor(Fg, Bg : integer) : string;
  153.       VAR
  154.          FgStr, BgStr, Temp : string;
  155.  
  156.       BEGIN
  157.          str(ColorArray[Fg mod 8] + 30, FgStr);
  158.          str(ColorArray[Bg mod 8] + 40, BgStr);
  159.          Temp := #27+'[';
  160.          if Bg > 7 then
  161.             Temp := Temp+'5;'
  162.          else
  163.             Temp := Temp+'0;';
  164.          if Fg > 7 then
  165.             Temp := Temp+'1;'
  166.          else
  167.             Temp := Temp+'2;';
  168.          ANSIColor := Temp+FgStr+';'+BgStr+'m';
  169.       END;
  170.  
  171. {****************************************************************************}
  172. {***                                                                      ***}
  173. {*** Function that returns an ANSI code representing a music string ("s") ***}
  174. {***                                                                      ***}
  175. {****************************************************************************}
  176.    FUNCTION ANSIMusic(s : string) : string;
  177.  
  178.       BEGIN
  179.          ANSIMusic := #27+'[MF'+s+#14;
  180.       END;
  181.  
  182. {****************************************************************************}
  183. {***                                                                      ***}
  184. {***  Procedure that simulates BASIC's "PLAY" procedure.  Will also work  ***}
  185. {***      with ANSI codes.  Taken from PC Magazine Volume 9 Number 3      ***}
  186. {***                                                                      ***}
  187. {****************************************************************************}
  188.    PROCEDURE Play(SoundC : string);
  189.       FUNCTION IsNumber(ch : char) : boolean;
  190.          BEGIN
  191.             IsNumber := (CH >= '0') AND (CH <= '9');
  192.          END;
  193.  
  194.    {Converts a string to an integer}
  195.       FUNCTION value(s : string) : integer;
  196.          VAR
  197.             ss, sss : integer;
  198.          BEGIN
  199.             Val(s, ss, sss);
  200.             value := ss;
  201.          END;
  202.  
  203.    {Plays the selected note}
  204.       PROCEDURE sounder(key : char; flag : char);
  205.          VAR
  206.             old, New, new2 : Real;
  207.          BEGIN
  208.             adder := 1;
  209.             old := dly;
  210.             New := dly;
  211.             intern := Pos(key, 'C D EF G A B')-1;
  212.             IF (flag = '+') AND (key <> 'E') AND (key <> 'B') {See if note}
  213.                THEN Inc(intern);                              {is sharped }
  214.             IF (flag = '-') AND (key <> 'F') AND (key <> 'C')
  215.                THEN Dec(intern);                              {or a flat. }
  216.             WHILE SoundC[vari+1] = '.' DO
  217.                BEGIN
  218.                   Inc(vari);
  219.                   adder := adder/2;
  220.                   New := New+(old*adder);
  221.                END;
  222.             new2 := (New/typom)*(1-typom);
  223.             sound(Round(Exp((octave+intern/12)*Ln(2)))); {Play the note}
  224.             Delay(Trunc(New));
  225.             Nosound;
  226.             Delay(Trunc(new2));
  227.          END;
  228.  
  229.    {Calculate delay for a specified note length}
  230.       FUNCTION delayer1 : integer;
  231.          BEGIN
  232.             numb := value(SoundC[vari+1]);
  233.             delayer1 := Trunc((60000/(numb*min1))*typom);
  234.          END;
  235.  
  236.    {Used as above, except reads a number >10}
  237.  
  238.       FUNCTION delayer2 : Integer;
  239.          BEGIN
  240.             numb := value(SoundC[vari+1]+SoundC[vari+2]);
  241.             delayer2 := Trunc((60000/(numb*min1))*typom);
  242.          END;
  243.  
  244.       BEGIN                           {Play}
  245.          SoundC := SoundC+' ';
  246.          FOR vari := 1 TO Length(SoundC) DO
  247.             BEGIN                     {Go through entire string}
  248.                SoundC[vari] := Upcase(SoundC[vari]);
  249.                CASE SoundC[vari] OF
  250. {Check to see}    'C','D','E',
  251. {if char is a}    'F','G','A',
  252. {note}            'B' : BEGIN
  253.                            flager := ' ';
  254.                            dlykeep := dly;
  255.                            chartoplay := SoundC[vari];
  256.                            IF (SoundC[vari+1] = '-') OR
  257.                               (SoundC[vari+1] = '+') THEN
  258. {Check for flats & sharps}    BEGIN
  259.                                  flager := SoundC[vari+1];
  260.                                  Inc(vari);
  261.                               END;
  262.                            IF IsNumber(SoundC[vari+1]) THEN
  263.                               BEGIN
  264.                                  IF IsNumber(SoundC[vari+2]) THEN
  265.                                     BEGIN
  266.                                        test := delayer2;
  267. {Make sure # is legal}                 IF numb < 65 THEN
  268.                                           dly := test;
  269.                                        Inc(vari, 2);
  270.                                     END
  271.                                  ELSE
  272.                                     BEGIN
  273.                                        test := delayer1;
  274. {Make sure # is legal}                 IF numb > 0 THEN
  275.                                           dly := test;
  276.                                        Inc(vari);
  277.                                     END;
  278.                               END;
  279.                            sounder(chartoplay, flager);
  280.                            dly := dlykeep;
  281.                         END;
  282. {Check for}       'O' : BEGIN
  283. {octave change}            Inc(vari);
  284.                            CASE SoundC[vari] OF
  285.                               '-' : IF octave > 1 THEN Dec(octave);
  286.                               '+' : IF octave < 7 THEN Inc(octave);
  287.                               '1','2','3',
  288.                               '4','5','6',
  289.                               '7' : octave := value(SoundC[vari])+4;
  290.                            ELSE Dec(vari);
  291.                            END;
  292.                         END;
  293. {Check for a}     'L' : IF IsNumber(SoundC[vari+1]) THEN
  294. {change in length}         BEGIN
  295. {for notes}                   IF IsNumber(SoundC[vari+2]) THEN
  296.                                  BEGIN
  297.                                     test := delayer2;
  298.                                     IF numb < 65 THEN
  299. {Make sure # is legal}                 dly := test;
  300.                                     Inc(vari, 2);
  301.                                  END
  302.                               ELSE
  303.                                  BEGIN
  304.                                     test := delayer1;
  305.                                     IF numb > 0 THEN
  306. {Make sure # is legal}                 dly := test;
  307.                                     Inc(vari);
  308.                                  END;
  309.                            END;
  310. {Check for pause} 'P' : IF IsNumber(SoundC[vari+1]) THEN
  311. {and it's length}          BEGIN
  312.                               IF IsNumber(SoundC[vari+2]) THEN
  313.                                  BEGIN
  314.                                     test := delayer2;
  315.                                     IF numb < 65 THEN
  316. {Make sure # is legal}                 Delay(test);
  317.                                     Inc(vari, 2);
  318.                                  END
  319.                               ELSE
  320.                                  BEGIN
  321.                                     test := delayer1;
  322.                                     IF numb > 0 THEN
  323. {Make sure # is legal}                 Delay(test);
  324.                                     Inc(vari);
  325.                                  END;
  326.                            END;
  327. {Check for}       'T' : IF IsNumber(SoundC[vari+1]) AND
  328. {tempo change}             IsNumber(SoundC[vari+2]) THEN
  329.                            BEGIN
  330.                               IF IsNumber(SoundC[vari+3]) THEN
  331.                                  BEGIN
  332.                                     min1 := value(SoundC[vari+1]+
  333.                                             SoundC[vari+2]+SoundC[vari+3]);
  334.                                     Inc(vari, 3);
  335.                                     IF min1 > 255 THEN
  336. {Make sure # isn't too big}            min1 := 255;
  337.                                  END
  338.                               ELSE
  339.                                  BEGIN
  340.                                     min1 := value(SoundC[vari+1]+
  341.                                             SoundC[vari+2]);
  342.                                     IF min1 < 32 THEN
  343. {Make sure # isn't too small}          min1 := 32;
  344.                                  END;
  345.                               min1 := min1/4;
  346.                            END;
  347. {Check for music} 'M' : BEGIN
  348. {type}                     Inc(vari);
  349.                            CASE Upcase(SoundC[vari]) OF
  350. {Normal}                      'N' : typom := 7/8;
  351. {Legato}                      'L' : typom := 1;
  352. {Staccato}                    'S' : typom := 3/4;
  353.                            END;
  354.                         END;
  355.                END;
  356.             END;
  357.       END;
  358.  
  359. {****************************************************************************}
  360. {***                                                                      ***}
  361. {***    Procedure to process string "s" and write its contents to the     ***}
  362. {***          screen, interpreting ANSI codes as it goes along.           ***}
  363. {***                                                                      ***}
  364. {****************************************************************************}
  365.    PROCEDURE ANSIWrite(s : string);
  366.       VAR
  367.          SaveX, SaveY : byte;
  368.          MusicStr : string;
  369.          MusicPos : integer;
  370.  
  371.    {*** Procedure to process the actual ANSI sequence ***}
  372.       PROCEDURE ProcessEsc;
  373.          VAR
  374.             DeleteNum : integer;
  375.             ts : string[5];
  376.             Num : array[0..10] of shortint;
  377.             Color : integer;
  378.  
  379.          LABEL
  380.             loop;
  381.  
  382.       {*** Procedure to extract a parameter from the ANSI sequence and ***}
  383.       {*** place it in "Num" ***}
  384.          PROCEDURE GetNum(cx : byte);
  385.             VAR
  386.                code : integer;
  387.             BEGIN
  388.                ts := '';
  389.                WHILE (s[1] in ['0'..'9']) and (length(s) > 0) DO
  390.                   BEGIN
  391.                      ts := ts + s[1];
  392.                      Delete(s,1,1);
  393.                   END;
  394.                val(ts,Num[cx],code)
  395.             END;
  396.  
  397.          BEGIN
  398.             IF s[2] <> '[' THEN exit;
  399.             Delete(s,1,2);
  400.             IF (UpCase(s[1]) = 'M') and (UpCase(s[2]) in ['F','B']) THEN
  401. {play music}   BEGIN
  402.                   Delete(s,1,2);
  403.                   MusicPos := pos(#14,s);
  404.                   Play(copy(s,1,MusicPos-1));
  405.                   DeleteNum := MusicPos;
  406.                   Goto Loop;
  407.                END;
  408.             fillchar(Num,sizeof(Num),#0);
  409.             GetNum(0);
  410.             DeleteNum := 1;
  411.             WHILE (s[1] = ';') and (DeleteNum < 11) DO
  412.                BEGIN
  413.                   Delete(s,1,1);
  414.                   GetNum(DeleteNum);
  415.                   DeleteNum  := DeleteNum + 1;
  416.                END;
  417.             CASE UpCase(s[1]) of
  418. {move up}      'A' : BEGIN
  419.                         if Num[0] = 0 THEN
  420.                            Num[0] := 1;
  421.                         WHILE Num[0] > 0 DO
  422.                            BEGIN
  423.                               GotoXY(wherex,wherey - 1);
  424.                               Num[0] := Num[0] - 1;
  425.                            END;
  426.                         DeleteNum := 1;
  427.                      END;
  428. {move down}    'B' : BEGIN
  429.                         if Num[0] = 0 THEN
  430.                            Num[0] := 1;
  431.                         WHILE Num[0] > 0 DO
  432.                            BEGIN
  433.                               GotoXY(wherex,wherey + 1);
  434.                               Num[0] := Num[0] - 1;
  435.                            END;
  436.                         DeleteNum := 1;
  437.                      END;
  438. {move right}   'C' : BEGIN
  439.                         if Num[0] = 0 THEN
  440.                            Num[0] := 1;
  441.                         WHILE Num[0] > 0 DO
  442.                            BEGIN
  443.                               GotoXY(wherex + 1,wherey);
  444.                               Num[0] := Num[0] - 1;
  445.                            END;
  446.                         DeleteNum := 1;
  447.                      END;
  448. {move left}    'D' : BEGIN
  449.                         if Num[0] = 0 THEN
  450.                            Num[0] := 1;
  451.                         WHILE Num[0] > 0 DO
  452.                            BEGIN
  453.                               GotoXY(wherex - 1,wherey);
  454.                               Num[0] := Num[0] - 1;
  455.                            END;
  456.                         DeleteNum := 1;
  457.                      END;
  458. {goto x,y}     'H',
  459.                'F' : BEGIN
  460.                         if (Num[0] = 0) THEN
  461.                            Num[0] := 1;
  462.                         if (Num[1] = 0) THEN
  463.                            Num[1] := 1;
  464.                         GotoXY(Num[1],Num[0]);
  465.                         DeleteNum := 1;
  466.                      END;
  467. {save current} 'S' : BEGIN
  468. {position}              SaveX := wherex;
  469.                         SaveY := wherey;
  470.                         DeleteNum := 1;
  471.                      END;
  472. {restore}      'U' : BEGIN
  473. {saved position}        GotoXY(SaveX,SaveY);
  474.                         DeleteNum := 1;
  475.                      END;
  476. {clear screen} 'J' : BEGIN
  477.                         if Num[0] = 2 THEN
  478.                            ClrScr;
  479.                         DeleteNum := 1;
  480.                      END;
  481. {clear from}   'K' : BEGIN
  482. {cursor position}       ClrEOL;
  483. {to end of line}        DeleteNum := 1;
  484.                      END;
  485. {change}       'M' : BEGIN
  486. {colors and}            DeleteNum := 0;
  487. {attributes}            WHILE (Num[DeleteNum] <> 0) or (DeleteNum = 0) DO
  488.                            BEGIN
  489.                               CASE Num[DeleteNum] of
  490. {all attributes off}             0 : BEGIN
  491.                                         NormVideo;
  492.                                         Bold := false;
  493.                                      END;
  494. {bold on}                        1 : Bold := true;
  495. {blink on}                       5 : textattr := textattr + blink;
  496. {reverse on}                     7 : textattr := ((textattr and $07) shl 4) +
  497.                                      ((textattr and $70) shr 4);
  498. {invisible on}                   8 : textattr := 0;
  499. {general foregrounds}            30..
  500.                                  37 : BEGIN
  501.                                          color := ColorArray[Num[DeleteNum]
  502.                                                   - 30];
  503.                                          IF Bold THEN
  504.                                             color := color + 8;
  505.                                          textcolor(color);
  506.                                       END;
  507. {general backgrounds}            40..
  508.                                  47 : textbackground(
  509.                                       ColorArray[Num[DeleteNum] - 40]);
  510.                               END;
  511.                               DeleteNum := DeleteNum + 1;
  512.                            END;
  513.                         DeleteNum := 1;
  514.                      END;
  515. {change text}  '=',
  516. {modes}        '?' : BEGIN
  517.                         Delete(s,1,1);
  518.                         GetNum(0);
  519.                         if UpCase(s[1]) = 'H' THEN
  520.                            BEGIN
  521.                               CASE Num[0] of
  522.                                  0 : TextMode(bw40);
  523.                                  1 : TextMode(co40);
  524.                                  2 : TextMode(bw80);
  525.                                  3 : TextMode(co80);
  526.                                  4 : GraphColorMode;
  527.                                  5 : GraphMode;
  528.                                  6 : HiRes;
  529.                                  7 : TruncateLines := false;
  530.                               END;
  531.                            END;
  532.                         if UpCase(s[1]) = 'L' THEN
  533.                            if Num[0] = 7 THEN
  534.                               TruncateLines := true;
  535.                         DeleteNum := 1;
  536.                      END;
  537.             END;
  538. loop:       Delete(s,1,DeleteNum);
  539.          END;
  540.  
  541.       BEGIN
  542.          WHILE length(s) > 0 DO
  543.             BEGIN
  544.                if s[1] = #27 THEN
  545.                   ProcessEsc
  546.                else
  547.                   BEGIN
  548.                      Write(s[1]);
  549.                      Delete(s,1,1);
  550.                   END;
  551.             END;
  552.       END;
  553.  
  554. {****************************************************************************}
  555. {***                                                                      ***}
  556. {***         Procedure that calls ANSIWrite, then line feeds.             ***}
  557. {***                                                                      ***}
  558. {****************************************************************************}
  559.    PROCEDURE ANSIWriteLn(s : string);
  560.       BEGIN
  561.          ANSIWrite(s);
  562.          WriteLn;
  563.       END;
  564.  
  565.    BEGIN
  566.       Octave := 4;
  567.       ChartoPlay := 'N';
  568.       Typom := 7/8;
  569.       Min1 := 120;
  570.       TruncateLines := false;
  571.    END.
  572.  
  573. {----------------------------   DEMO PROGRAM  ------------------ }
  574.  
  575. PROGRAM Atype;
  576.  
  577.    USES
  578.       ANSIIO,
  579.       DOS,
  580.       CRT;
  581.  
  582.    VAR
  583.       F : text;
  584.       S, L : string;
  585.       Ch : char;
  586.       i : integer;
  587.       Rec : searchrec;
  588.  
  589.    FUNCTION PathOnly(p1 : string) : string;
  590.       VAR
  591.          s, p : string;
  592.          i, t : integer;
  593.       BEGIN
  594.          p := p1;
  595.          i := 0;
  596.          REPEAT
  597.             t := i;
  598.             i := pos('\',p);
  599.             IF i > 0 THEN
  600.                p[i] := '|';
  601.          UNTIL i = 0;
  602.          IF t = 0 THEN
  603.             t := pos(':',p);
  604.          p1 := copy(p1,1,t);
  605.          IF length(p1) > 2 THEN
  606.             IF p1[length(p1)] <> '\' THEN
  607.                p1 := p1+'\';
  608.          PathOnly := p1;
  609.       END;
  610.  
  611.    BEGIN
  612.       IF ParamCount < 1 then
  613.          BEGIN
  614.             writeln;
  615.             writeln('Usage : ATYPE file1 file2 file3 ...',
  616.                     '                       (Wildcards are OK)');
  617.             EXIT;
  618.          END;
  619. {$I-} FOR i := 1 to ParamCount DO
  620.          BEGIN
  621.             s := PathOnly(ParamStr(i));
  622.             FindFirst(ParamStr(i),AnyFile,Rec);
  623.             WHILE DosError = 0 do
  624.                BEGIN
  625.                   assign(f,s+Rec.name);
  626.                   reset(f);
  627.                   WHILE (not eof(f)) and (IOResult = 0) do
  628.                      BEGIN
  629.                         readln(f,l);
  630.                         ANSIWriteln(l);
  631.                      END;
  632.                   close(f);
  633.                   While KeyPressed do
  634.                      ch := readkey;
  635.                   Repeat until KeyPressed;
  636.                   FindNext(Rec);
  637.                END;
  638.          END;
  639. {$I+}
  640.    END.
  641.